home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / cmdlg2 / cmdialog.bas next >
BASIC Source File  |  1995-05-09  |  17KB  |  536 lines
  1. Rem Demo for accessing Win 3.1 Common Dialogs
  2. Rem Author: Costas Kitsos, CIS 73667,1755
  3. Rem Revision: 1.00.00, July 4 1992
  4.  
  5. Rem Modified: L.J. Johnson, CIS 70700,1334
  6. Rem Revision: 1.10.00, July 25 1992
  7.  
  8. DefInt A-Z
  9.  
  10. Declare Function lstrcpy Lib "Kernel" (ByVal lpDestString As Any, ByVal lpSourceString As Any) As Long
  11.  
  12. Function PColors% (MyForm As Form, CError&, Flags&)
  13.  
  14.     MyForm.Cls
  15.     PColors% = 0: CError& = 0
  16.  
  17.     Dim C As ChooseColor
  18.     Dim Address As Long
  19.     ReDim ClrArray(15) As Long    ' Holds Custom Colors
  20.  
  21.     wSize = Len(ClrArray(0)) * 16 ' Size of Memory Block
  22.  
  23.  
  24.     ' ----------------------------------------------------
  25.     ' A global block is allocated to hold a copy of the
  26.     '   custom colors
  27.     ' ----------------------------------------------------
  28.     MemHandle = GlobalAlloc(GHND, wSize)
  29.     If MemHandle = 0 Then
  30.         PColors% = 1
  31.         Exit Function
  32.     End If
  33.  
  34.     Address = GlobalLock(MemHandle)
  35.     If Address = 0 Then
  36.         PColors% = 2
  37.         Exit Function
  38.     End If
  39.     ' ----------------------------------------------------
  40.  
  41.  
  42.     ' ----------------------------------------------------
  43.     ' Fill Custom Colors with White
  44.     ' ----------------------------------------------------
  45.     For i& = 0 To UBound(ClrArray)
  46.         ClrArray(i&) = &HFFFFFF
  47.     Next
  48.     ' ----------------------------------------------------
  49.  
  50.     
  51.     ' ----------------------------------------------------
  52.     'copy custom colors to the global block
  53.     ' ----------------------------------------------------
  54.     Call hmemcpy(ByVal Address, ClrArray(0), wSize)
  55.     ' ----------------------------------------------------
  56.  
  57.     
  58.     ' ----------------------------------------------------
  59.     'get ready to call ChooseColor
  60.     ' ----------------------------------------------------
  61.     C.lStructSize = Len(C)
  62.     C.hwndOwner = MyForm.hwnd
  63.     C.lpCustColors = Address
  64.     C.RgbResult = Dialogs.BackColor
  65.     C.Flags = Flags&
  66.  
  67.     Result = ChooseColor(C)
  68.     CError& = CommDlgExtendedError()
  69.     
  70.     If Result = 0 Then
  71.         PColors% = 3
  72.         Exit Function
  73.     End If
  74.     ' ----------------------------------------------------
  75.  
  76.  
  77.     ' ----------------------------------------------------
  78.     ' copy the new custom colors locally
  79.     ' ----------------------------------------------------
  80.     Call hmemcpy(ClrArray(0), ByVal Address, wSize)
  81.     
  82.     OK = GlobalUnlock(MemHandle)    'Free The Memory
  83.     OK = GlobalFree(MemHandle)
  84.     ' ----------------------------------------------------
  85.  
  86.     
  87.     ' ----------------------------------------------------
  88.     ' Select the new color for the background
  89.     ' Comment this out if it's distracting
  90.     ' Print the new custom colors
  91.     ' ----------------------------------------------------
  92.     MyForm.BackColor = C.RgbResult
  93.     For i& = 0 To UBound(ClrArray)
  94.         MyForm.Print "Custom Color"; Str$(i&); ":", Hex$(ClrArray(i&))
  95.     Next
  96.     ' ----------------------------------------------------
  97.  
  98. End Function
  99.  
  100. Function PFileOpen% (MyForm As Form, FError&, Filter$, IDir$, Title$, Index%, Flags&)
  101.  
  102.     MyForm.Cls
  103.     PFileOpen% = 0: SaveError% = 0
  104.  
  105.     Dim O As OPENFILENAME
  106.     Dim Address As Long
  107.  
  108.     ' ----------------------------------------------------
  109.     ' First Copy the strings to the Global Memory Block
  110.     ' Use a sub-allocation scheme to avoid overloading
  111.     '   the LDT
  112.     ' ----------------------------------------------------
  113.     szFile$ = String$(256, 0)
  114.     
  115.     szFilter$ = Filter$
  116.     szInitialDir$ = IDir$
  117.     szTitle$ = Title$
  118.  
  119.     wSize = Len(szFile$) + Len(szFilter$) + Len(szInitialDir$) + Len(szTitle$)
  120.     
  121.     MemHandle = GlobalAlloc(GHND, wSize)
  122.  
  123.     If MemHandle = 0 Then
  124.         PFileOpen% = 1
  125.         Exit Function
  126.     End If
  127.     ' ----------------------------------------------------
  128.  
  129.     
  130.     ' ----------------------------------------------------
  131.     ' Lock global memory, then copy it to local memory
  132.     ' ----------------------------------------------------
  133.     Address = GlobalLock(MemHandle)
  134.     If Address = 0 Then
  135.         PFileOpen% = 2
  136.         Exit Function
  137.     Else
  138.         Call hmemcpy(ByVal Address, ByVal (szFile$ + szFilter$ + szInitialDir$ + szTitle$), wSize)
  139.     End If
  140.     ' ----------------------------------------------------
  141.     
  142.     O.lStructSize = Len(O)
  143.     O.hwndOwner = MyForm.hwnd
  144.     O.Flags = Flags&
  145.     O.nFilterIndex = Index%
  146.     O.lpstrFile = Address
  147.     O.nMaxFile = Len(szFile$)
  148.     O.lpstrFilter = Address + Len(szFile$)
  149.     O.lpstrInitialDir = O.lpstrFilter + Len(szFilter$)
  150.     O.lpstrTitle = O.lpstrInitialDir + Len(szInitialDir$)
  151.  
  152.     Result = GetOpenFileName(O)
  153.     FError& = CommDlgExtendedError()
  154.     
  155.     If Result = 0 Then
  156.         PFileOpen% = 3
  157.     Else
  158.         Call hmemcpy(ByVal szFile$, ByVal Address, Len(szFile$))
  159.     End If
  160.     
  161.     OK = GlobalUnlock(MemHandle)    'Free The Memory
  162.     OK = GlobalFree(MemHandle)
  163.  
  164.     If Result = 0 Then Exit Function
  165.  
  166.     File$ = Left$(szFile$, InStr(szFile$, Chr$(0)) - 1)
  167.     MyForm.Print "Common Dialogs File Open"
  168.     MyForm.Print
  169.     MyForm.Print "You selected:", File$
  170.     MyForm.Print "Path:", Left$(File$, O.nFileOffset)
  171.     MyForm.Print "Filename:", Right$(File$, Len(File$) - O.nFileOffset)
  172.     MyForm.Print "Extension:", Right$(File$, Len(File$) - O.nFileExtension)
  173.  
  174. End Function
  175.  
  176. Function PFileSave% (MyForm As Form, FError&, Filter$, IDir$, FileMask$, Index%, Title$, Flags&)
  177.  
  178.     MyForm.Cls
  179.     PFileSave% = 0: FError& = 0
  180.  
  181.     ' This is similar to GetOpenFileName
  182.     Dim S As OPENFILENAME
  183.     Dim Address As Long
  184.  
  185.     ' ----------------------------------------------------
  186.     ' First Copy the strings to the Global Memory Block
  187.     ' Use a sub-allocation scheme to avoid wearing down
  188.     '   the LDT
  189.     ' ----------------------------------------------------
  190.     NoTitle$ = FileMask$
  191.     szFile$ = NoTitle$ + String$(256 - Len(NoTitle$), 0)
  192.     szFilter$ = Filter$
  193.     szInitialDir$ = IDir$
  194.     szTitle$ = Title$
  195.     wSize = Len(szFile$) + Len(szFilter$) + Len(szInitialDir$) + Len(szTitle$)
  196.  
  197.     MemHandle = GlobalAlloc(GHND, wSize)
  198.  
  199.     If MemHandle = 0 Then
  200.         PFileSave% = 1
  201.         Exit Function
  202.     End If
  203.  
  204.     Address = GlobalLock(MemHandle)
  205.     If Address = 0 Then
  206.         PFileSave% = 2
  207.         Exit Function
  208.     Else
  209.         Call hmemcpy(ByVal Address, ByVal (szFile$ + szFilter$ + szInitialDir$ + szTitle$), wSize)
  210.     End If
  211.  
  212.     S.lStructSize = Len(S)
  213.     S.hwndOwner = MyForm.hwnd
  214.     S.Flags = Flags&
  215.     S.nFilterIndex = Index%
  216.     S.lpstrFile = Address
  217.     S.nMaxFile = Len(szFile$)
  218.     S.lpstrFilter = Address + Len(szFile$)
  219.     S.lpstrInitialDir = S.lpstrFilter + Len(szFilter$)
  220.     S.lpstrTitle = S.lpstrInitialDir + Len(szInitialDir$)
  221.  
  222.     Result = GetSaveFileName(S)
  223.     FError& = CommDlgExtendedError()
  224.  
  225.     If Result = 0 Then
  226.         PFileSave% = 3
  227.         Exit Function
  228.     Else
  229.         Call hmemcpy(ByVal szFile$, ByVal Address, Len(szFile$))
  230.     End If
  231.  
  232.     OK = GlobalUnlock(MemHandle)    'Free The Memory
  233.     OK = GlobalFree(MemHandle)
  234.  
  235.     File$ = Left$(szFile$, InStr(szFile$, Chr$(0)) - 1)
  236.     MyForm.Print "Common Dialogs File Save"
  237.     MyForm.Print
  238.     MyForm.Print "You selected:", File$
  239.     MyForm.Print "Path:", Left$(File$, S.nFileOffset)
  240.     MyForm.Print "Filename:", Right$(File$, Len(File$) - S.nFileOffset)
  241.     MyForm.Print "Extension:", Right$(File$, Len(File$) - S.nFileExtension)
  242.  
  243. End Function
  244.  
  245. Function PFonts% (MyForm As Form, FError&, Flags&, FontType%)
  246.     
  247.     MyForm.Cls
  248.     PFonts% = 0: FError& = 0
  249.  
  250.     Dim A As ChooseFont
  251.     Dim F As LogFont
  252.     Dim Address As Long
  253.  
  254.  
  255.     ' ----------------------------------------------------
  256.     ' Save the defaults
  257.     ' ----------------------------------------------------
  258.     OldFont$ = Dialogs.FontName
  259.     OldFontSize = Dialogs.FontSize
  260.     OldFontWeight = Dialogs.FontBold
  261.     OldFontItalic = Dialogs.FontItalic
  262.     OldFontStrikethru = Dialogs.FontStrikethru
  263.     OldFontUnderline = Dialogs.FontUnderline
  264.     OldFore